Delphi Informant Complete 1995 - 2000/Delphi Informant Complete 1995 to 2000.iso/Delphi Informant Magazine Complete Works SOURCE CODE 1998.rar/1998/Nov/di9811gd/Example3/Unit1.pas

Pascal/Delphi Source File | 1998-03-10 | 6KB | 214 lines

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls;

type
  { TLightThread }
  {* For easy management of threads.                                          *}
  {* Allows a thread to be "created" with a passed thread function. The       *}
  {* function will exit cleanly when ThreadExiting is set to true, or         *}
  {* "nastily" after a timeout of ThreadExitTimeout milliseconds.             *}
  {* For the purposes of this example, though, we are pretty assured that the *}
  {* ThreadFunc used will always exit cleanly... (How else to demonstrate     *}
  {* a thread-safe DLL?)                                                      *}
  TLightThread = class(TObject)
  protected
    FThreadHandle: THandle;
    FThreadID: DWord;
    FCS: TRTLCriticalSection;
    FThreadExiting: Boolean;
    function GetThreadExiting: Boolean;
  public
    constructor Create(ThreadFunc: TThreadFunc);
    destructor Destroy; override;
    property ThreadExiting: Boolean read GetThreadExiting;
    property ThreadHandle: THandle read FThreadHandle;
    property ThreadID: DWord read FThreadID;
  end;

  { TForm1 }
  TForm1 = class(TForm)
    btnLoad: TButton;
    btnUnload: TButton;
    lbThreads: TListBox;
    Label1: TLabel;
    btnNewThread: TButton;
    btnCloseThread: TButton;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure btnLoadClick(Sender: TObject);
    procedure btnUnloadClick(Sender: TObject);
    procedure btnNewThreadClick(Sender: TObject);
    procedure btnCloseThreadClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    LibHandle: THandle;
    ThreadList: TList;
    procedure FreeLib;
    procedure NewThread;
    procedure CloseThread(Idx: Integer); { Close indexed thread. }
    procedure CloseThreads;
  end;

var
  Form1: TForm1;

const
  ThreadSleepLength = 50; // 50 ms.
  ThreadExitTimeout = 10000;

implementation

{$R *.DFM}

function ThreadFunc(Parameter: Pointer): Integer;
begin
  while (not TLightThread(Parameter).ThreadExiting) do
    Sleep(ThreadSleepLength);
  result := 0;
end;

{ TLightThread }
constructor TLightThread.Create(ThreadFunc: TThreadFunc);
begin
  InitializeCriticalSection(FCS);
  FThreadExiting := False;
  try
    FThreadHandle :=
      BeginThread(nil, 0, ThreadFunc, Pointer(Self), 0, FThreadID);
  except
    on E: Exception do begin
      DeleteCriticalSection(FCS);
      raise;
    end;
  end;
end;

destructor TLightThread.Destroy;
begin
  EnterCriticalSection(FCS);
  try
    FThreadExiting := True;
  finally
    LeaveCriticalSection(FCS);
  end;
  WaitForSingleObject(FThreadHandle, ThreadExitTimeout);
  CloseHandle(FThreadHandle);
  DeleteCriticalSection(FCS);
  inherited;
end;

function TLightThread.GetThreadExiting: Boolean;
begin
  EnterCriticalSection(FCS);
  try
    result := FThreadExiting;
  finally
    LeaveCriticalSection(FCS);
  end;
end;


{ TForm1 }

procedure TForm1.FormCreate(Sender: TObject);
begin
  LibHandle := 0;
  ThreadList := TList.Create;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  FreeLib;                           // Free the library, if necessary
  CloseThreads;                      // Guarantee that threads are closed.
  ThreadList.Free;                   // Free the list of threads.
end;

procedure TForm1.btnLoadClick(Sender: TObject);
begin
  if LibHandle = 0 then
    LibHandle := LoadLibrary('Dll3.dll');
end;

procedure TForm1.btnUnloadClick(Sender: TObject);
begin
  FreeLib;                           // Free the library, if necessary
end;

procedure TForm1.btnNewThreadClick(Sender: TObject);
begin
  NewThread;
end;

procedure TForm1.btnCloseThreadClick(Sender: TObject);
begin
  CloseThread(lbThreads.ItemIndex);
end;

procedure TForm1.FreeLib;
var
  i, Cnt: Integer;
begin
  {* In comments is the appropriate way for a calling application
     to free its library when it has multiple threads; however, for
     the purpose of the example, we _just_ unload the library *}
  FreeLibrary(LibHandle);
  LibHandle := 0;
  {if LibHandle <> 0 then begin
    try
      Cnt := ThreadList.Count;
      for i := 0 to Cnt - 1 do CloseThread(0);
      FreeLibrary(LibHandle);
    finally
      LibHandle := 0;
    end;
  end;}
end;

procedure TForm1.NewThread;
var
  Thd: TLightThread;
begin
  { Create a thread }
  Thd := TLightThread.Create(ThreadFunc);
  { If thread was created successfully, then add the thread handle to
    ThreadList, increment thread count and add an "identifier" to
    the ListBox (for identification purposes only). }
  ThreadList.Add(Pointer(Thd));
  lbThreads.Items.Add('Thread #' + IntToStr(Thd.ThreadHandle));
  lbThreads.ItemIndex := lbThreads.Items.Count - 1;
end;

procedure TForm1.CloseThread(Idx: Integer);
begin
  if (Idx >= 0) and (Idx < ThreadList.Count) then begin
    TLightThread(ThreadList.Items[Idx]).Free;
    ThreadList.Delete(Idx);  ThreadList.Pack;
    lbThreads.Items.Delete(Idx);
    if (Idx = ThreadList.Count) then
      lbThreads.ItemIndex := Idx - 1
    else
      lbThreads.ItemIndex := Idx;
  end;
end;

procedure TForm1.CloseThreads;
var
  i, Cnt: Integer;
begin
  Cnt := ThreadList.Count;
  for i := 0 to Cnt - 1 do CloseThread(0);
end;

initialization

  IsMultiThread := True;

end.